COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C  SUBRS. VLINE, ASKIT, GRED, LPEN, DELETE, DPYNEW, PLTCMD
C00021 ENDMK
C⊗;
C  SUBRS. VLINE, ASKIT, GRED, LPEN, DELETE, DPYNEW, PLTCMD
C*****  SAVIT, LISTP, FIXUP  ***************


	SUBROUTINE VLINE(R3,R4,R5,R6)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
6	TYPE 3
	ACCEPT F78F,R3,R4,R5,R6
	REREAD FA1,ASK
	IF(ASK.EQ.'B')R3=99
C  99 IS ALSO USED IN MOVER.F4
	IF(R3.GE.99)RETURN
	IF(ASK.NE.'L')GO TO 66
C  TYPE 'L' FOR LIGHT-PEN
	K=-1
67	R4=RY
	CALL LPEN(R3,RY,RX)
	REREAD FA1,ASK
	IF(ASK.EQ.'B')R3=99
	IF(R3.GE.99)RETURN
	K=-K
	IF(K.GT.0)GO TO 67
	R5=RY
C LIGHT PEN IS READ TWICE
66	ASK=-1
	IF(R6.LT.100)GO TO 1
	R6=R6-100
C  FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
	ASK=0
1	CALL BOX(-1,R4)
	CALL BOX(-2,R5)
C  PUTS UP TWO VERTICAL LINES
3	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
	END

	SUBROUTINE ASKIT
	COMMON /DPY/ST(4000),WDS(250),MEDIT,IGO
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
	COMMON /XRN/RN(2000) /KJY/ K,JY
	IGO=0
	CALL DPYNEW
	X=ST(2)
	CALL BOX(JY,RN(JY+2))
	ST(2)=X
	TYPE 1
	ACCEPT FA1,K
	IF(K.EQ.'G')ASK=-1
	CALL DPYNEW
	IGO=1
1	FORMAT(' N=NO, <CR>=YES, G=GO  '$)
	END

	SUBROUTINE GRED
	INTEGER PWDS
	COMMON /DPY/IST(4000),IWDS(250),MEDIT,IGO
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /KJY/ K,JY
	COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	COMMON R2,JA,J,J2,RJQ(6),RC,IZ,RX,KV,RY,IA,IB,C,D,JZ,A,
	1 NX,VY,RB,JQ(20) /XRN/RN(2000) /ALF/INP(72),ML
	COMMON /PTR/PWDS(250),ITEM,L,I,IX/POSI/STFF(8),JJB,POS
	COMMON/RINP/R(10,80),RPOS(100)

	EQUIVALENCE (IST2,IST(2))
	RC=999
	RSTF=RC
CC **CAN'T GET HERE ***IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
C  LEAVES ROUTINE
7	CALL VLINE(R2,Z,POS,RX)
C  PUTS UP TWO VERTICAL LINES
	REREAD FA1,NX
	IF(NX.EQ.'B')GO TO 170
	IF(R2.LT.99)GO TO 70
170	JA=98
	RETURN
70	IF(POS.EQ.0)POS=200
C  0,0  DOES WHOLE STAFF
	IF(INP(1).NE.'A')GO TO 4
	TYPE 55
	ACCEPT F78F,V
	REREAD FA1,K
C  TYPE 'L' FOR LIGHT PEN
	IF(V(1).EQ.99)GO TO 7
	IF(K.EQ.'B')GO TO 7
C TYPE 'B' OR 99 TO BACKUP
	IF(K.NE.'L')GO TO 66
	DO 67 K=1,2
	V(2)=RY
	CALL LPEN(V(1),RY,RX)
	REREAD FA1,JA
	IF(JA.EQ.'B')GO TO 7
67	IF(V(1).GE.99)GO TO 7
	V(3)=RY
66	JA=0
	IZ=0
C  COUNTER
	GO TO 14
4	JA=98
C  FOR DELETIONS
C  STF.N, -99    -- DELETES ALL BUT STAFF N.
	IF(Z.NE.-99)GO TO 14
	RSTF=R2
	R2=99
14	NX=0
C  LOOP STARTS HERE
	J=0
140	NX=NX+1
142	JY=PWDS(NX)
	RB=RN(JY+3)
	IF(RTLINE(JY))GO TO 6
	IF(RB.LT.Z)GO TO 6
	IF(RB.GT.POS)GO TO 6
	IF(RN(JY+2).EQ.RSTF)GO TO 6
C  FOR -99 DELETES.
	RB=RN(JY+1)
	IF(V(1).EQ.12)GO TO 77
	IF(V(1).EQ.100)GO TO 341
C USE P100 AND ANY CODE# TO CREATE CUES. I.E. MINI NOTES, RESTS, BEAMS.
	IF(RC.EQ.999)GO TO 143
C  USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
C  SET 12 TO 1 WITH CODE 5 TO INVERT SLURS ONLY
77	RC=0
	IF(RB.EQ.5)GO TO 141
	IF(RB.NE.6)GO TO 143
	IF(RX.EQ.1)GO TO 141
143	IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
	IF(ASK)GO TO 100
	CALL ASKIT
	IF(K.EQ.'N')GO TO 6
	IF(K.EQ.'X')GO TO 19
100	IF(INP(1).EQ.'A')GO TO 141
	IF(J)GO TO 40
	J=-1
	K=NX
41	IZ=NX
	IF(NX.LT.ITEM)GO TO 140
40	IF(NX-IZ.EQ.1)GO TO 41
C  GO BACK FOR MORE - IF IN RIGHT ORDER.
C  RANGE TO DEL. = K→NX
45	J=IZ+1
	IA=PWDS(K)
	IB=PWDS(J)-IA
	JZ=IWDS(K)
	J2=IWDS(J)-JZ
	J=J-K
	ITEM=ITEM-J
	DO 42 IZ=K,ITEM+1
	PWDS(IZ)=PWDS(IZ+J)-IB
42	IWDS(IZ)=IWDS(IZ+J)-J2
	IST2=IST2-J2
	I=I-IB
	 CALL LOOP(IA,I,1,0,IB,RN)
	CALL LOOP(JZ+2,IST2+2,1,0,J2,IST)
	IF(K.GE.ITEM)GO TO 1
C  EXITS
	NX=K+1
	GO TO 142
341	IF(RB.EQ.6)GO TO 141
	IF(RB.GT.2)GO TO 6
141	IF(IZ.GE.97)GO TO 9
C   THERE'S A LIMIT TO THE R ARRAY    4/18/73
	IZ=IZ+1
C  FOUND AN ITEM
	R(1,IZ)=22
	R(2,IZ)=NX
10	IZ=IZ+1
	DO 101 KV=3,10
101	R(KV,IZ)=0
	IF(V(1).NE.100)GO TO 131
231	R(1,IZ)=400
C  MAKES MINI NOTES, RESTS, BEAMS
	R(2,IZ)=100
	GO TO 6
131	IF(RC.EQ.999)GO TO 11
	IF(RB.EQ.1)GO TO 30
31	RC=RN(JY+7)
	IF(RB.EQ.6)GO TO 32
C  NEXT INVERTS DIP
	IF(RX.EQ.1)GO TO 35
	A=-1.6
	RB=-10
	IF(RC)A=-A
36	R(7,IZ)=2
	R(8,IZ)=RN(JY+2)+A
	GO TO 37
35	RB=-4
	IF(RN(JY+8).LT.-1)RB=-1.4
C  2 AND .7 ARE HGTS SET IN 'BEAMS'
37	IF(RC)RB=-RB
	R(3,IZ)=4
	R(4,IZ)=RN(JY+4)+RB
	R(6,IZ)=RN(JY+5)+RB
	R(5,IZ)=5
33	R(1,IZ)=7
	R(2,IZ)=-RC
	GO TO 6
32	IF(RC.LT.20)GO TO 34
C  THIS IS FOR BEAMS
232	RC=10-RC
	GO TO 33
132	IF(RC.GT.-20)GO TO 232
	GO TO 332
34	IF(RC)GO TO 132
C  P7 IS NEG FOR TREMOLOS
332	RC=-10-RC
	GO TO 33

C  NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
C  MUST! BE FIRST IN LIST!!!
C	RC=0
30	RB=RN(JY+5)
	IF(RB.LT.10)GO TO 12
C  NO STEM < 10
	RC=10
	IF(RB.GE.20)RC=-RC
	RB=RB+RC
12	V(1)=5.
	V(2)=RB
C  SO IT WILL DISPLAY RESULT
11	DO 8 K=1,10
8	R(K,IZ)=V(K)
6	IF(J)GO TO 45
	IF(NX.LT.ITEM)GO TO 140
19	IF(INP(1).NE.'A')GO TO 1
9	R(1,IZ+1)=222
	R(1,IZ+2)=0
CC	REND=-1.
1	CALL HYDPOG(3)
55	FORMAT(' TYPE',3(' P#, CHNG ')/)
	END

	SUBROUTINE LPEN(A,B,C)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /SIZ/RSZ,JCEN,KCEN
	COMMON /POSI/STFF(0/7),JJ2,POS /ALF/INP(71),M,L /C/MM,LL
CC5	CALL SETCUR(0,100,0)
	M=MM
	L=LL
	IF(IABS(M).GT.512)GO TO 4
	IF(IABS(L).LE.512)GO TO 3
4	M=0
	L=100
3	CALL SETCUR(M,L,0)
	TYPE 17
	ACCEPT FA1,D
	IF(D.EQ.'9')RETURN
	IF(D.EQ.'X')RETURN
C  TYPE 'B' OR 99 TO BACK UP
	IF(D.EQ.'B')RETURN
	CALL RDCUR(M,L)
CC	CALL CLRCUR
	L=(L+KCEN)/RSZ
1	B=((M+JCEN)/RSZ+596.0)/5.96
C  B=HORIZ. STEP NUM.
	DO 13 K=0,7
	M=STFF(K)+60.
	IF(L.GT.M)GO TO 13
	A=K
C  A=STAFF NUM.
	GO TO 8
13	CONTINUE
17	FORMAT(' TYPE <CR> TO SET POINT'/)
8	C=IFIX((L-STFF(K)+21.)/7.+.5)
C  FINDS VERT. NOTE NUM.
	TYPE F78F,A,B
	END



CC	SUBROUTINE DELETE
CC	IMPLICIT INTEGER(A-Q,S-Z)
CC	COMMON/DL/X22,SAVER,NAME
CC	COMMON /XRN/RN(4000)
CC	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(15),R6,DEL,X,JY,K
CC	COMMON/PTR/PWDS(250),ITEM,L,I,IX
CC	COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
CC	EQUIVALENCE (ST2,ST(2))

CC1	X=ITEM
CC171	IX=I
CC	L=RN(MEDIT)+3.0
C  SIZE OF DELETION
CC	I=IX-L
CC	CALL LOOP(MEDIT,I,1,0,L,RN)
CC	JY=WDS(X22+1)-WDS(X22)
CC	CALL LOOP(WDS(X22)+2,WDS(X),1,0,JY,ST)
CC	K=X22
CC194	N=K+1
CC	WDS(N)=WDS(N+1)-JY
CC	PWDS(K)=PWDS(N)-L
CC	K=N
CC	IF(K.LT.X)GO TO 194
C  ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
CC	ITEM=ITEM-1
CC	IF(X22.GT.ITEM)X22=ITEM
CC	J2=ITEM
CC	ITEM=ITEM-1
CC195	ST2=WDS(J2)
CC271	CALL DPYNEW
CC	END


CF	SUBROUTINE DPYNEW
CF	COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
CF	CALL ACCPOG(1)
CP14	KA=0
CP3	KA=KA+1
CP	IF(MLL.EQ.0)GO TO 15
CP	K=K-2
CP	MLL=MLL-1
CP	IF(MLL.EQ.0)GO TO 10
CP	GO TO 31
CP15	TYPE 2,KA
CP	ACCEPT 11,K,MLL,RSPC
C  TYPE LAST NAME, NUMBER  FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
CP50	IF(K.EQ.' ')GO TO 10
CP	IF(K.EQ.'99')GO TO 140
C  99=BACKUP
CP31	IF(LOOKD(K))GO TO 56
C JUMP IF FILE FOUND
CP	TYPE 55
CP	GO TO 15
CP55	FORMAT(' FILE NOT FOUND'/)
CP11	FORMAT(A5,I,F)
CP56	NMS(KA)=K
CP	IF(MLL.EQ.0)GO TO 5
CP	R8='Y'
CP	IF(RSPC.NE.0)R8=RSPC
CP	GO TO 21
CP5	TYPE 8
CP	ACCEPT FA5,R8
CP	IF(R8.EQ.'99')GO TO 15
CP	IF(R8.NE.'Y')R8=0
CP	IF(R8.EQ.0)REREAD F78F,R8
C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
CP21	RMOV1(KA+1)=R8
CP	RMOV2(KA)=R8
CP	GO TO 3
CP140	KA=KA-1
CP	GO TO 15

CP10	KB=KA-1
CP	TYPE 9
CP	ACCEPT F78F,RS
CP	RSIZ=RS
CP	IF(RSIZ.EQ.0)GO TO 5
CP	IF(RSIZ.EQ.99)GO TO 5
CP	KA=0

CP1	IF(NAME.NE.0)GO TO 12
CP	IF(KA.EQ.KB)CALL EXIT
CP	NAME=NMS(KA+1)
CP	TYPE 111,NAME
CP	RETURN
CP12	KA=KA+1
CP	NAME=0
C  'PL' = CALCOMP OUTPUT
CP	R8=0
CP	R2=RS
CP	R3=RS
CP	R7=0
CP	R5=1
CP	R6=1
CP	IF(RMOV2(KA).NE.'Y')R7=RMOV2(KA)
CP	IF(RMOV1(KA).NE.0)R5=0
CP	IF(RMOV2(KA).NE.0)GO TO 277
CP	IF(R7.EQ.0)RETURN
CP277	R6=0
CP2	FORMAT(' TYPE FILE NAME',I2,1X$)
CP8	FORMAT(' MOVE UP AT END? ',$)
CP9	FORMAT(' SIZE FACTOR? ',$)
CP111	FORMAT(1XA5/)
CP	END


	SUBROUTINE SAVIT
	IMPLICIT INTEGER(A-Q,S-Z)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
	COMMON/DL/X22,SAVER,NAME,EXT/POSI/STFF(0/7),JJ2,IPOS
	COMMON/SCM/V(78),ISCR,LCNT,IRSTF,LIST(200),REND /LIMIT/LIMIT
	1 /ALF/INP(72),ML/XRN/RN(2000)/DPY/ST(4000),WDS(250),MEDIT,IGO
	1 /STF/RSTFAC(0/7),RSTJC/PTR/PWDS(250),ITEM,L,I,IX
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	DATA EXT/'DMD'/
	DIMENSION SV(128)
	EQUIVALENCE (INP2,INP(2)),(ST2,ST(2)),(SV,LIST)
C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE FOR21.DAT.
	KX=-1
	K=0
32	K=K+1
C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
33	L=PWDS(K)
	IA=PWDS(K+1)
	IB=RN(L)+3.+L
C  THIS SHOULD BE NEW POINTER
	IF(IA-IB.EQ.0)GO TO 36
	IF(RN(IB)+3+IB.NE.PWDS(K+2))GO TO 38
	J=K+1
	PWDS(J)=IB
	TYPE 30,J
	GO TO 36
30	FORMAT(' ?FIXED UP ITEM ',I4)
38	IJ=IA-L
	DO 39 J2=K+1,ITEM
39	PWDS(J2)=PWDS(J2+1)-IJ
	TYPE 31,K
	IF(KX.EQ.0)GO TO 50
	TYPE 21
CF	ACCEPT FA5,NAME
	ACCEPT 141,INP
	CALL NAMEXT(INP,NAME,EXT)
C  ONLY DOES THIS ON THE FIRST ERROR
	GO TO 2
50	J=RJ
	KX=0
	CALL LOOP(L,I,1,0,J,RN)
C  REARRANGES DATA
	I=I-J
	ITEM=ITEM-1
	IF(ITEM.LE.K)GO TO 37
	GO TO 33
C  GO BACK AND TRY AGAIN
36	IF(IA.LE.L)GO TO 38
C  JUMP IF PWDS IS OUT OF ORDER
	IF(K.LT.ITEM)GO TO 32
31	FORMAT(' BAD ITEM--',I4/)
37	KX=-1
	IF(SAVER.GE.0)GO TO 10
CC101	REWIND 21
	SAVER=7
101	CALL PUTEXT('TMP','DMD')
	GO TO 102
3	FORMAT(' WRITE OVER ',A5,'.',A3,'?  ',$)
CC3	FORMAT(' WRITE OVER ',A5,'.DAT?  ',$)
1	FORMAT(I,24F)
2	TYPE 3,NAME,EXT
CF	ACCEPT FA1,L
CF	IF(L.NE.'N')GO TO 4
	ACCEPT 141,INP
	IF(INP(1).NE.'N')GO TO 4
10	IF(INP2.NE.'M')GO TO 11
	INP2='B'
	GO TO 4
11	L=NAME
	INP(1)=-1
	CALL NAMEXT(INP,NAME,EXT)
CF	CALL FORMAT(NAME)
	IF(NAME.NE.' ')GO TO 40
	TYPE 21
CF	ACCEPT 141,NAME,X,X
	ACCEPT 141,INP   
	CALL NAMEXT(INP,NAME,EXT)
	IF(NAME.EQ.' ')GO TO 4
CF	IF(X.NE.' ')EXT=X
C 99 WILL BACK UP.
	IF(NAME.NE.'99')GO TO 40
	NAME=L
	RETURN
40	IF(NAME.NE.'SAME')GO TO 43
	NAME=L
	GO TO 4
141	FORMAT(72A1)
CF141	FORMAT(A5,A1,A3)
CC43	IF(LOOKD(NAME))GO TO 2
43	IF(LOOKX(NAME,EXT))GO TO 2
C  JUMP BACK IF FILE NAME ALREADY ON DSK
4	IF(KX.EQ.0)GO TO 50
CC	REWIND 21
	IF(NAME.NE.' ')GO TO 41
	NAME=L
	GO TO 101
CC	CALL OFILE(21,NAME)
41	CALL PUTEXT(NAME,EXT)
CC	GO TO 42
CC41	NAME=L
42	IF(INP2.EQ.'D')GO TO 202
C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
102	IRSTF=0
	IF(INP2.EQ.'B')IRSTF=-1
	JJ2=ITEM+2
	IPOS=I
C WD CNTS
	CALL EXTOUT(RSTFAC,128)
C  INCLUDES STFF AND V ARRAYS
	CALL EXTOUT(PWDS,JJ2)
	CALL EXTOUT(RN,IPOS)
	IF(LCNT.GT.1)CALL EXTOUT(LIST,LCNT)
CC102	WRITE(21)ITEM,I
CC	1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
CC	1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,SV
C (SV) FOR FORTRAN READ BUG!!!!
CC	IF(SAVER.GE.0)WRITE(21)RSTFAC,STFF,L
C NOT USED WHEN SAVE IS AUTOMATIC.
C  TAKE OUT ABOVE WHEN BUG IS SOMEDAY FIXED IN F4.
	IF(I.GT.2000 )TYPE 20,I
CCC	IF(I.GT.LIMIT)TYPE 20,I,LIMIT
CC	IF(INP2.NE.'B')GO TO 1001
	IF(INP2.EQ.'B')CALL EXTOUT(ST,4250)
CC	WRITE(21)ST2,(ST(L),L=1,ST2+2),(WDS(L),L=1,ITEM+1)
CC1001	END FILE 21
1001	CALL FINEXT
	IF(INP(1).NE.'S')RETURN
	IF(NAME.EQ.' ')TYPE 5600
C   GO BACK IF THE SAVER WROTE THE FILE
	RETURN
20	FORMAT(' ****** TOO MUCH DATA TO PRINT - ',I4,'/2000')
CCC20	FORMAT(' ****** TOO MUCH DATA TO PRINT - ',I4,'/',I4)
202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
 	GO TO 1001
C   WRITES DPY BUFFER ONLY.
5600	FORMAT(' DISPLAY SAVED IN ''TMP.DMD'''/)
21	FORMAT(' NAME.EXT?  '$)
	END

	SUBROUTINE LISTP(LST)
	IMPLICIT INTEGER(A-Q,S-Z)
	DIMENSION LST(13)
	COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),K,JY,X,Y
	COMMON /XRN/RN(2000) /PTR/PWDS(250),ITEM,L,I,IX
	EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(RJC,RJQ(1)),(RJD,RJQ(2))

	CALL NOZERO(R2)
	JC=RJC
	IF(JC.EQ.0)JC=ITEM
	JY=5
	JD=RJD
	IF(JD.NE.0)JY=3
	DO 6334 L=IFIX(R2),JC
	X=PWDS(L)
	Y=RN(X)+2+X
	X=X+1
	K=RN(X)
	IF(K.EQ.13)K=11
	IF(K.GE.11)K=K-1
	IF(K.GE.15)K=K-4
6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
C  P, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
63331	FORMAT(8F10.4)
6333	FORMAT(I4,') ',A5,2F4.0,F8.3,F8.2,7F10.2)
	END